home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / mosmllib / Intmap.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  7.0 KB  |  209 lines  |  [TEXT/R*ch]
  1. (* Intmap -- modified for Moscow ML from SML/NJ library v. 0.2.
  2.  *
  3.  * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.  
  4.  * See file mosml/copyrght/copyrght.att for details.
  5.  *
  6.  * This code was adapted from Stephen Adams' binary tree implementation
  7.  * of applicative integer sets.
  8.  *
  9.  *   Copyright 1992 Stephen Adams.
  10.  *
  11.  *    This software may be used freely provided that:
  12.  *      1. This copyright notice is attached to any copy, derived work,
  13.  *         or work including all or part of this software.
  14.  *      2. Any derived work must contain a prominent notice stating that
  15.  *         it has been altered from the original.
  16.  *
  17.  *
  18.  *   Name(s): Stephen Adams.
  19.  *   Department, Institution: Electronics & Computer Science,
  20.  *      University of Southampton
  21.  *   Address:  Electronics & Computer Science
  22.  *             University of Southampton
  23.  *         Southampton  SO9 5NH
  24.  *         Great Britian
  25.  *   E-mail:   sra@ecs.soton.ac.uk
  26.  *
  27.  *   Comments:
  28.  *
  29.  *     1.  The implementation is based on Binary search trees of Bounded
  30.  *         Balance, similar to Nievergelt & Reingold, SIAM J. Computing
  31.  *         2(1), March 1973.  The main advantage of these trees is that
  32.  *         they keep the size of the tree in the node, giving a constant
  33.  *         time size operation.
  34.  *
  35.  *     2.  The bounded balance criterion is simpler than N&R's alpha.
  36.  *         Simply, one subtree must not have more than `weight' times as
  37.  *         many elements as the opposite subtree.  Rebalancing is
  38.  *         guaranteed to reinstate the criterion for weight>2.23, but
  39.  *         the occasional incorrect behaviour for weight=2 is not
  40.  *         detrimental to performance.
  41.  *
  42.  *  Altered to work as a geneal intmap - Emden Gansner
  43.  *)
  44.  
  45. exception NotFound
  46.  
  47. fun wt (i : int) = 3 * i
  48.  
  49. datatype 'a intmap = 
  50.   E 
  51. | T of {
  52.     key : int, 
  53.     value : 'a, 
  54.     cnt : int, 
  55.     left : 'a intmap, 
  56.     right : 'a intmap
  57. }
  58.  
  59. fun numItems E = 0
  60.   | numItems (T{cnt,...}) = cnt
  61.  
  62. local
  63.     fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
  64.       | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r}
  65.       | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E}
  66.       | N(k,v,l as T n,r as T n') = 
  67.           T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r}
  68.  
  69.     fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = 
  70.           N(b,bv,N(a,av,x,y),z)
  71.       | single_L _ = raise Match
  72.     fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = 
  73.           N(a,av,x,N(b,bv,y,z))
  74.       | single_R _ = raise Match
  75.     fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) =
  76.           N(b,bv,N(a,av,w,x),N(c,cv,y,z))
  77.       | double_L _ = raise Match
  78.     fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = 
  79.           N(b,bv,N(a,av,w,x),N(c,cv,y,z))
  80.       | double_R _ = raise Match
  81.  
  82.     fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
  83.       | T' (k,v,E,r as T{right=E,left=E,...}) =
  84.           T{key=k,value=v,cnt=2,left=E,right=r}
  85.       | T' (k,v,l as T{right=E,left=E,...},E) =
  86.           T{key=k,value=v,cnt=2,left=l,right=E}
  87.  
  88.       | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p
  89.       | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p
  90.  
  91.         (* these cases almost never happen with small weight*)
  92.       | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
  93.           if ln < rn then single_L p else double_L p
  94.       | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
  95.           if ln > rn then single_R p else double_R p
  96.  
  97.       | T' (p as (_,_,E,T{left=E,...})) = single_L p
  98.       | T' (p as (_,_,T{right=E,...},E)) = single_R p
  99.  
  100.       | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...},
  101.                       r as T{cnt=rn,left=rl,right=rr,...})) =
  102.           if rn >= wt ln then (*right is too big*)
  103.             let val rln = numItems rl
  104.                 val rrn = numItems rr
  105.             in
  106.               if rln < rrn then  single_L p  else  double_L p
  107.             end
  108.         
  109.           else if ln >= wt rn then  (*left is too big*)
  110.             let val lln = numItems ll
  111.                 val lrn = numItems lr
  112.             in
  113.               if lrn < lln then  single_R p  else  double_R p
  114.             end
  115.     
  116.           else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r}
  117.  
  118.     local
  119.       fun min (T{left=E,key,value,...}) = (key,value)
  120.         | min (T{left,...}) = min left
  121.         | min _ = raise Match
  122.   
  123.       fun delmin (T{left=E,right,...}) = right
  124.         | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right)
  125.         | delmin _ = raise Match
  126.     in
  127.       fun delete' (E,r) = r
  128.         | delete' (l,E) = l
  129.         | delete' (l,r) = let val (mink,minv) = min r in
  130.             T'(mink,minv,l,delmin r)
  131.           end
  132.     end
  133. in
  134.     fun empty () = E
  135.     
  136.     fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E}
  137.       | insert (T(set as {key,left,right,value,...}),x,v) =
  138.           if key > x then T'(key,value,insert(left,x,v),right)
  139.           else if key < x then T'(key,value,left,insert(right,x,v))
  140.           else T{key=x,value=v,left=left,right=right,cnt= #cnt set}
  141.  
  142.     fun retrieve (set, x) = let 
  143.       fun mem E = raise NotFound
  144.         | mem (T(n as {key,left,right,...})) =
  145.             if x > key then mem right
  146.             else if x < key then mem left
  147.             else #value n
  148.       in mem set end
  149.  
  150.     fun peek arg = (SOME(retrieve arg)) handle NotFound => NONE
  151.  
  152.     fun remove (E,x) = raise NotFound
  153.       | remove (set as T{key,left,right,value,...},x) =
  154.           if key > x then 
  155.             let val (left',v) = remove(left,x)
  156.             in (T'(key,value,left',right),v) end
  157.           else if key < x then
  158.             let val (right',v) = remove(right,x)
  159.             in (T'(key,value,left,right'),v) end
  160.           else (delete'(left,right),value)
  161.  
  162.     fun listItems d = let
  163.       fun d2l E res = res
  164.         | d2l (T{key,value,left,right,...}) res =
  165.       d2l left ((key,value) :: d2l right res)
  166.       in d2l d [] end
  167.  
  168.     fun app f d = let
  169.       fun a E = ()
  170.         | a (T{key,value,left,right,...}) = (a left; f(key,value); a right)
  171.       in a d end
  172.  
  173.     fun revapp f d = let
  174.       fun a E = ()
  175.         | a (T{key,value,left,right,...}) = (a right; f(key,value); a left)
  176.       in a d end
  177.  
  178.     fun foldr f init d = let
  179.       fun a E v = v
  180.         | a (T{key,value,left,right,...}) v = a left (f(key,value,a right v))
  181.       in a d init end
  182.  
  183.     fun foldl f init d = let
  184.       fun a E v = v
  185.         | a (T{key,value,left,right,...}) v = a right (f(key,value,a left v))
  186.       in a d init end
  187.  
  188.     fun map f d = let
  189.       fun a E = E
  190.         | a (T{key,value,left,right,cnt}) = let
  191.             val left' = a left
  192.             val value' = f(key,value)
  193.             in
  194.               T{cnt=cnt, key=key,value=value',left = left', right = a right}
  195.             end
  196.       in a d end
  197.  
  198.     fun transform f d = let
  199.       fun a E = E
  200.         | a (T{key,value,left,right,cnt}) = let
  201.             val left' = a left
  202.             val value' = f value
  203.             in
  204.               T{cnt=cnt, key=key,value=value',left = left', right = a right}
  205.             end
  206.       in a d end
  207.  
  208. end
  209.